Syntax10.Scn.Fnt
ParcElems
Alloc
Syntax24b.Scn.Fnt
FoldElems
Syntax10b.Scn.Fnt
(* AMIGA  *)
MODULE Fonts; (* shml/cn 29-Dec-1992, 10-May-94 *)
IMPORT
		SYSTEM, Amiga, DiskFont := AmigaDiskFont, Display, E := AmigaExec, Files, G := AmigaGraphics, C:=Console;
CONST
 	FontFileId = 0DBX;
	Name* = ARRAY 32 OF CHAR;
	Font* = POINTER TO FontDesc;
	FontDesc* = RECORD
		name*: Name;
		height*, minX*, maxX*, minY*, maxY*: INTEGER;
		raster*: Display.Font;
		next: Font
	END;
	Default*, First: Font; nofFonts: INTEGER;
PROCEDURE SplitFontName (fn: ARRAY OF CHAR; VAR i, j, size: INTEGER);
	VAR k: INTEGER;
BEGIN i := 0; size := 0;
	WHILE (fn[i] # 0X) & ((fn[i] < "0") OR ("9" < fn[i])) DO INC(i) END;
	j := i; WHILE ("0" <= fn[j]) & (fn[j] <= "9") DO INC(j) END;
	k := i; WHILE k < j DO size := size * 10 + ORD(fn[k]) - 30H; INC(k) END
END SplitFontName;
PROCEDURE Cleanup;
	raster: Amiga.Font;
BEGIN
	IF Amiga.ChipMemPool=0 THEN
		WHILE First # NIL DO
			raster := SYSTEM.VAL(Amiga.Font, First.raster);
			IF (raster.data#0) & (raster.size#0) THEN E.FreeMem(raster.data, raster.size) END;
			First := First.next
		END
	ELSE
		First:=NIL
	END;
	Default := NIL
END Cleanup;
PROCEDURE ClearRaster(VAR raster:Amiga.Font);
	dummy: Amiga.CharInfo;
	i:INTEGER;
BEGIN
	dummy.dx:=0;
	dummy.x:=0;
	dummy.y:=0;
	dummy.w:=0;
	dummy.h:=0;
	dummy.modulo:=0;
	dummy.data:=0;
	dummy.offset:=0;
	FOR i:=0 TO 255 DO
		raster.info[i]:=dummy
	END;
	raster.data:=0;
	raster.size:=0
END ClearRaster;
PROCEDURE SearchFont(name:ARRAY OF CHAR):Font;
	f:Font;
BEGIN
	f:=First;
	LOOP
		IF f=NIL THEN EXIT END;
		IF name=f.name THEN EXIT END;
		f:=f.next
	END;
	RETURN f
END SearchFont;
PROCEDURE AmigaFont(name: ARRAY OF CHAR): Font;
	TextFontPtr=POINTER TO G.TextFont;
	font:Font;
	raster:Amiga.Font;
	tf:TextFontPtr;
	af:G.TextFontPtr;
	PROCEDURE DuplicateBlock(src:LONGINT; size:LONGINT):LONGINT;
		b:SHORTINT;
		dst:LONGINT;
		i:LONGINT;
	BEGIN
		IF Amiga.ChipMemPool#0 THEN
			dst:=E.AllocPooled(Amiga.ChipMemPool, size)
		ELSE
			dst:=E.AllocMem(size,{E.memChip})
		END;
		FOR i:=0 TO size-1 DO SYSTEM.GET(src+i,b); SYSTEM.PUT(dst+i,b) END;
		RETURN dst
	END DuplicateBlock;
	PROCEDURE OpenAmigaFont(name:ARRAY OF CHAR):G.TextFontPtr;
		fontName:ARRAY 32 OF CHAR;
		fontSize:INTEGER;
		fontStyles:SHORTINT;
		i,j:INTEGER;
		textAttr:G.TextAttr;
	BEGIN
		COPY(name,fontName);
		fontStyles:=0;
		SplitFontName(name, i, j, fontSize);
	This will not work, if the fonts are handle in this way.
		LOOP
			CASE fontName[j] OF
			| "B","b": INC(fontStyles,2); INC(j)
			| "C","c": INC(fontStyles,64); INC(j)
			| "E","e": INC(fontStyles,8); INC(j)
			| "I","i": INC(fontStyles,4); INC(j)
			| "U","u": INC(fontStyles,1); INC(j)
			ELSE EXIT
			END;
		END;
		fontName[i]:="."; fontName[i+1]:="f"; fontName[i+2]:="o"; fontName[i+3]:="n"; fontName[i+4]:="t";
		fontName[i+5]:=0X;
		textAttr.name:=SYSTEM.ADR(fontName);
		textAttr.ySize:=fontSize;
		textAttr.style:=fontStyles;
		textAttr.flags:=0;
		RETURN DiskFont.OpenDiskFont(textAttr)
	END OpenAmigaFont;
	PROCEDURE SetFontAndRaster(VAR font:Font; VAR raster:Amiga.Font; tf:TextFontPtr);
	TYPE
		Location=RECORD offset,width:INTEGER END;
		LocationArray=ARRAY 256 OF Location;
		LocationPtr=POINTER TO LocationArray;
		SpaceArray=ARRAY 256 OF INTEGER;
		SpacePtr=POINTER TO SpaceArray;
		KernArray=ARRAY 256 OF INTEGER;
		KernPtr=POINTER TO KernArray;
		ch:INTEGER;
		dx,x,y,w,h:SHORTINT;
		i:INTEGER;
		kern:KernPtr;
		loc:LocationPtr;
		minX,maxX:INTEGER;
		space:SpacePtr;
		li:LONGINT;
	BEGIN
		loc:=SYSTEM.VAL(LocationPtr, tf.charLoc);
		space:=SYSTEM.VAL(SpacePtr, tf.charSpace);
		kern:=SYSTEM.VAL(KernPtr, tf.charKern);
		y:=SHORT(tf.baseline-tf.ySize+1);
		h:=SHORT(tf.ySize);
		font.minY:=y;
		font.maxY:=y+h;
		minX:=MAX(INTEGER); maxX:=MIN(INTEGER);
		raster.size:=tf.modulo*h;
		raster.data:=DuplicateBlock(tf.charData,raster.size);
		FOR ch:=ORD(tf.loChar) TO ORD(tf.hiChar) DO
			i:=ch-ORD(tf.loChar);
			IF space#NIL THEN dx:=SHORT(space[i]) ELSE dx:=SHORT(tf.xSize) END;
			x:=0; IF kern#NIL THEN dx:=dx+SHORT(kern[i]); x:=SHORT(kern[i]) END;
			IF loc#NIL THEN w:=SHORT(loc[i].width) ELSE w:=SHORT(tf.xSize) END;
			IF x<minX THEN minX:=x END;
			IF x+w>maxX THEN maxX:=x+w END;
			raster.info[ch].dx:=dx;
			raster.info[ch].x:=x;
			raster.info[ch].y:=y;
			raster.info[ch].w:=w;
			raster.info[ch].h:=h;
			raster.info[ch].modulo:=tf.modulo;
			raster.info[ch].data:=raster.data;
			IF loc#NIL THEN raster.info[ch].offset:=loc[i].offset ELSE raster.info[ch].offset:=w*i END
		END;
		font.height:=h;
		font.minX:=minX;
		font.maxX:=maxX;
		font.raster:=SYSTEM.VAL(Display.Font,raster)
	END SetFontAndRaster;
BEGIN
	font:=Default;
	af:=OpenAmigaFont(name);
	tf:=SYSTEM.VAL(TextFontPtr, af);
	IF tf#NIL THEN
		NEW(raster);
		ClearRaster(raster);
		NEW(font);
		IF font=NIL THEN HALT(127) END;
		SetFontAndRaster(font,raster,tf);
		raster.amigaFont:=af;
		COPY(name,font.name);
		font.next:=First;
		First:=font;
		G.CloseFont(af)
	END;
	RETURN font
END AmigaFont;
PROCEDURE OberonFont(name: ARRAY OF CHAR): Font;
	RunRec=RECORD
		beg, end: INTEGER
	END;
	RunRecArray=ARRAY 16 OF RunRec;
	ch:CHAR;
	file:Files.File;
	font:Font;
	nOfRuns: INTEGER;
	raster: Amiga.Font;
	rider:Files.Rider;
	run:RunRecArray;
	PROCEDURE ReadShort(VAR r: Files.Rider; VAR x: SHORTINT);
		val: INTEGER;
	BEGIN
		Files.ReadInt(r, val); x := SHORT(val)
	END ReadShort;
	PROCEDURE ReadFontHeader(VAR r: Files.Rider; VAR f:Font; VAR nOfRuns:INTEGER; VAR run:RunRecArray);
		k:INTEGER;
	BEGIN
		Files.ReadInt(r,f.height);
		Files.ReadInt(r,f.minX);
		Files.ReadInt(r,f.maxX);
		Files.ReadInt(r,f.minY);
		Files.ReadInt(r,f.maxY);
		Files.ReadInt(r,nOfRuns);
		FOR k := 0 TO nOfRuns-1 DO
			Files.ReadInt(r,run[k].beg);
			Files.ReadInt(r,run[k].end)
		END
	END ReadFontHeader;
	PROCEDURE ReadRaster(VAR r:Files.Rider; VAR raster:Amiga.Font; VAR nOfRuns:INTEGER; VAR run:RunRecArray);
		a:LONGINT;
		j, bytesPerRow:LONGINT;
		i,k,m:INTEGER;
		nOfBytes:LONGINT;
	BEGIN
		nOfBytes:=0;
		FOR k:=0 TO nOfRuns-1 DO
			FOR m:=run[k].beg TO run[k].end-1 DO
				ReadShort(r,raster.info[m].dx);
				ReadShort(r,raster.info[m].x);
				ReadShort(r,raster.info[m].y);
				ReadShort(r,raster.info[m].w);
				ReadShort(r,raster.info[m].h);
				raster.info[m].modulo:=2*((raster.info[m].w+15) DIV 16);
				nOfBytes:=nOfBytes+raster.info[m].modulo*raster.info[m].h
			END
		END;
		IF Amiga.ChipMemPool#0 THEN
			raster.data:=E.AllocPooled(Amiga.ChipMemPool, nOfBytes)
		ELSE
			raster.data:=E.AllocMem(nOfBytes,{E.memChip})
		END;
		raster.size:=nOfBytes;
		a:=raster.data;
		FOR k:=0 TO nOfRuns-1 DO
			FOR m:=run[k].beg TO run[k].end-1 DO
				bytesPerRow:=(raster.info[m].w+7) DIV 8;
				raster.info[m].data:=a;
				raster.info[m].offset:=0;
				INC(a,LONG(raster.info[m].modulo)*(raster.info[m].h-1));
				FOR i:=1 TO raster.info[m].h DO
					FOR j:=1 TO bytesPerRow DO
						Files.Read(r,ch);
						SYSTEM.PUT(a,Amiga.SwapBits[ORD(ch)]);
						INC(a)
					END;
					DEC(a,bytesPerRow+raster.info[m].modulo)
				END;
				a:=raster.info[m].data+raster.info[m].modulo*raster.info[m].h
			END
		END
	END ReadRaster;
BEGIN
	file:=Files.Old(name);
	IF file#NIL THEN
		Files.Set(rider,file,0); Files.Read(rider,ch);
		IF ch=FontFileId THEN
			Files.Read(rider,ch);	(*skip abstraction*)
			Files.Read(rider,ch);	(*skip family*)
			Files.Read(rider,ch);	(*skip variant*)
			NEW(font);
			ReadFontHeader(rider,font,nOfRuns,run);
			NEW(raster);
			ClearRaster(raster);
			ReadRaster(rider,raster,nOfRuns,run);
			raster.amigaFont:=0;
			font.raster:=SYSTEM.VAL(Display.Font,raster);
			COPY(name,font.name);
			font.next:=First;
			First:=font
		ELSE
			font:=NIL
		END
	ELSE
		font:=NIL
	END;
	RETURN font
END OberonFont;
PROCEDURE This*(name: ARRAY OF CHAR):Font;(*
Load the named font, unless it is already loaded.
First try to load it as Obeorn font.
If this has no succsess, try it as Amiga font.
After all does not work, use Default font.
	font:Font;
BEGIN
	font:=SearchFont(name);
	IF font=NIL THEN
		font:=OberonFont(name);
		IF font=NIL THEN
			font:=AmigaFont(name);
			IF font=NIL THEN font:=Default END
		END
	END;
	RETURN font
END This;
BEGIN
	First:=NIL;
	nofFonts:=0;
	Default:=This("Syntax10.Scn.Fnt");
	Amiga.Assert(Default#NIL,"Default font not found");
	Amiga.TermProcedure(Cleanup)
END Fonts.